home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
The 640 MEG Shareware Studio 2
/
The 640 Meg Shareware Studio CD-ROM Volume II (Data Express)(1993).ISO
/
pascal
/
tpb4_src.zip
/
MSGMOVE.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1988-09-13
|
25KB
|
615 lines
{ TPBoard 4.2 Copyright (c) 1987,88 by Jon Schneider & Rick Petersen
Portions Copyright (c) 1986,87 by Steve Fox and Les Archambault
Last modified :: 8-25-88 8:30 pm
}
{$R-} {Range checking off}
{$B-} {Boolean complete evaluation off}
{$S-} {Stack checking off}
{$I+} {I/O checking on}
{$N-} {No numeric coprocessor}
Unit MsgMove;
Interface
Uses
TPCrt, Dos, TPDOS, Globals, Core1, Core2,
TAccess, TPSTRING, NetMisc, Misc;
procedure record_msg(fname : DosFileName);
procedure make_fido_message(area : Str13;
source : DosFileName;
from_loc,
to_loc : LongInt;
old_subj : Str72;
LocalEnter : Boolean;
to_full_name : Str36;
net, node : Integer;
FileAttach : Boolean);
{==========================================================================}
Implementation
procedure record_msg(fname : DosFileName);
var
Tfile : Text;
i, first_line,
last_line : Integer;
to_fn, Fr_fn : FirstName;
to_ln, Fr_ln : LastName;
Str : StrStd;
Tname : DosFileName;
temp_user_rec : user_list;
This : AreaPtr;
OK : Boolean;
begin
repeat
WriteLn(Com);
OK := False;
if fname = '' then
Tname := prompt('Filename to save msg to', 12, 'ES')
else
Tname := fname;
if Tname <> ' ' then
begin
Assign(Tfile, Tname);
{$I-}
Reset(Tfile); {$I+}
if IoResult <> 0 then
OK := True;
if OK then
begin
{$I-}
Rewrite(Tfile); {$I+}
OK := (IoResult = 0);
end
else
begin
WriteLn(Com);
if ask('File already exists...use anyway', 'Y') then
begin
{$I-}
Rewrite(Tfile); {$I+}
OK := (IoResult = 0);
end;
end;
end;
until OK or (not Online) or (Tname = ' ');
if OK and Online then
begin
WriteLn(Com);
if fname = '' then
Write(Com, 'Writing file...');
with summ_rec do
begin
if fname = '' then
begin
if user_to = 0 then
begin
to_fn := 'ALL';
to_ln := '';
end
else if user_to = user_loc then
begin
to_fn := user_rec.fn;
to_ln := user_rec.ln;
end
else
begin
GetRec(DatF, user_to, temp_user_rec);
to_fn := temp_user_rec.fn;
to_ln := temp_user_rec.ln;
end;
if user_from = user_loc then
begin
Fr_fn := user_rec.fn;
Fr_ln := user_rec.ln;
end
else
begin
GetRec(DatF, user_from, temp_user_rec);
Fr_fn := temp_user_rec.fn;
Fr_ln := temp_user_rec.ln;
end;
Str := FormTAD(date);
This := AreaBase;
while (This <> nil) and (This^.Area <> Area) do
This := This^.next;
WriteLn(Tfile);
if num_prev = 255 then
Write(Tfile, '<P>');
case status of
deleted :
Write(Tfile, 'Deleted');
Seen :
Write(Tfile, 'Read');
private :
Write(Tfile, 'Private');
public :
Write(Tfile, 'Public');
restricted :
Write(Tfile, 'Restricted');
end;
WriteLn(Tfile, ' Message # ', num, ' ', This^.AreaName, ' Area ', ' Entered ',
Str);
WriteLn(Tfile, 'From: ', Fr_fn, ' ', Fr_ln);
WriteLn(Tfile, ' To: ', to_fn, ' ', to_ln);
WriteLn(Tfile, ' Re: ', subject);
end;
first_line := st_rec;
last_line := size;
end; {with sum_rec}
i := 1;
Seek(mesg_file, first_line);
WriteLn(Tfile);
while (i <= last_line) and Online do
begin
Read(mesg_file, mesg_rec);
WriteLn(Tfile, mesg_rec);
Inc(i);
end;
Close(Tfile);
if fname = '' then
WriteLn(Com, 'Complete');
end; {ok and online}
end; {procedure}
procedure make_fido_message(area : Str13;
source : DosFileName;
from_loc,
to_loc : LongInt;
old_subj : Str72;
LocalEnter : Boolean;
to_full_name : Str36;
net, node : Integer;
FileAttach : Boolean);
var
to_fn, Fr_fn : FirstName;
to_ln, Fr_ln : LastName;
temp_user_rec : user_list;
buffer : array[1..512] of Byte;
mname,
FidoArea : StrPr;
OK, node_entrd,
abort, created,
file_not_saved : Boolean;
mfile : Text;
high_msg_num,
i, offset,
number,
remaining,
nodes,
position : Integer;
msgnum, reply : Str10;
subj : Str72;
file_time : tad_array;
to_name,
from_name : Str36;
DateStr : Str20;
low : Byte;
msg_line,
prev_line : string;
msg_file,
text_file : untype_file;
temp_area : DosFileName;
temp_str : string[4];
msg_footer : string;
begin
OK := True;
low := 1;
created := False;
temp_area := AreaReq;
AreaReq := Area;
Fido_sort(high_msg_num, number, msg_numbers);
AreaReq := temp_area;
Inc(high_msg_num);
Str(high_msg_num, msgnum);
if ((source = '') and local_online) then
begin
if LocalEnter or ask('Use editor to create file', 'Y') then
begin
created := LocalEnter;
if LocalEnter then
begin
DispName := Area;
if Pos('-', DispName) = 1 then
Delete(DispName, 1, 1);
mname := Copy(DispName, 1, 8)+'.MSG'
end
else
begin
mname := prompt('Name of file to create', 12, 'ES');
DispName := mname;
end;
if LocalEnter then
begin
DispName := to_full_name;
{$V-}
caps_to_mixed(DispName) {$V+} ;
DispName := ' To: '+DispName;
end;
DispName := PadCh(DispName, ' ', 10);
full_screen_edit(mname, 'W', file_not_saved);
if file_not_saved then
begin
Assign(mfile, mname);
{$I-}
Reset(mfile); {$I+}
if IoResult = 0 then
begin
Close(mfile);
Erase(mfile);
end;
end;
end
else
mname := prompt('Name of file in SYSTEM area to put into message', 12, 'ES');
end
else if source = '' then
mname := prompt('Name of file in SYSTEM area to put into message', 12, 'ES')
else
mname := source;
if mname <> ' ' then
begin
Assign(mfile, mname);
{$I-}
Reset(mfile); {$I+}
if IoResult <> 0 then
begin
WriteLn(Com);
WriteLn(Com, 'Message build aborted.');
WriteLn(Com);
OK := False;
end;
if OK then
begin
if source = '' then
begin
if (not LocalEnter) then
begin
WriteLn(Com);
Write(Com, ' From: > ', UserFullName);
end;
if (not LocalEnter) and (not ask(' OK', 'Y')) then
begin
from_name := prompt(' From: ', 35, 'EL');
from_name := StUpcase(from_name);
OK := ((from_name <> 'QUIT') and (from_name <> ''))
end {get new FROM name}
else
from_name := StUpcase(UserFullName);
end
else
begin
if from_loc = user_loc then
begin
Fr_fn := user_rec.fn;
Fr_ln := user_rec.ln;
end
else
begin
GetRec(DatF, from_loc, temp_user_rec);
Fr_fn := temp_user_rec.fn;
Fr_ln := temp_user_rec.ln;
end;
if Fr_fn = 'SYSOP' then
from_name := fido_sysop
else
from_name := Fr_fn+' '+Fr_ln;
end;
if OK then
begin
if source = '' then
begin
if (not LocalEnter) then
begin
to_name := prompt(' To: ', 35, 'EL');
to_name := StUpcase(to_name);
if to_name = '' then
to_name := 'ALL';
OK := ((to_name <> 'QUIT') and online);
if OK then
begin
subj := prompt('Subject: ', 71, 'EL');
WriteLn(Com);
if subj = '' then
subj := '....';
end;
end
else
begin
if to_full_name = '' then
to_name := 'All'
else
to_name := to_full_name;
OK := True;
subj := old_subj;
end;
end
else
begin
if to_loc = 0 then
begin
to_fn := 'ALL';
to_ln := '';
end
else if to_loc = user_loc then
begin
to_fn := user_rec.fn;
to_ln := user_rec.ln;
end
else
begin
GetRec(DatF, to_loc, temp_user_rec);
to_fn := temp_user_rec.fn;
to_ln := temp_user_rec.ln;
end;
if to_fn = 'SYSOP' then
to_name := fido_sysop
else
to_name := to_fn+' '+to_ln;
subj := old_subj
end;
if OK then
begin
if Area[1] <> '-' then
begin
if (not LocalEnter) then
repeat
node_entrd := False;
repeat
reply := prompt('Net (or CR for List) ', 9, 'ES');
if reply = '?' then
reply := ' ';
if reply = ' ' then
begin
show_nets;
WriteLn(Com);
WriteLn(Com)
end;
until (reply <> ' ') or (not Online);
position := Pos('/', reply);
if position <> 0 then
begin
temp_str := Copy(reply, Succ(position), 4);
msg_hdr.dest_node := strint(temp_str);
Delete(reply, position, 5);
node_entrd := True
end;
msg_hdr.dest_net := strint(reply);
check_net(msg_hdr.dest_net, offset, nodes, OK);
if (not OK) and (msg_hdr.dest_net <> 0) then
begin
WriteLn(Com, 'No such Net, try again.');
node_entrd := False
end;
abort := (msg_hdr.dest_net = 0);
until OK or (not Online) or abort;
if (not LocalEnter) then
repeat
if (not node_entrd) then
begin
repeat
reply := prompt('Node (CR for List) ', 4, 'ES');
if reply = '?' then
reply := ' ';
if (reply = ' ') then
begin
show_nodes(offset, nodes);
WriteLn(Com);
WriteLn(Com)
end;
until ((reply <> ' ') and (reply[1] in ['0'..'9']))
or (not Online);
msg_hdr.dest_node := strint(reply);
end;
check_node(msg_hdr.dest_node, offset, nodes, OK);
if (not OK) then
begin
WriteLn(Com, 'No such Node, try again.');
node_entrd := False
end;
until OK or (not Online);
WriteLn(Com);
if LocalEnter then
begin
node_entrd := True;
msg_hdr.dest_node := node;
msg_hdr.dest_net := net;
end;
if ask('Make the message public', 'N') then
clear_bit(low, 0);
if ask('Send via Crash mail', 'Y') then
set_bit(low, 1);
if FileAttach then
set_bit(low, 4)
end
else
clear_bit(low, 0);
GetTAD(file_time);
DateStr := Fido_FormTAD(file_time);
if from_name = 'SYSOP' then
from_name := fido_sysop;
with msg_hdr do
begin
FillChar(msg_from, 36, 0);
FillChar(msg_to, 36, 0);
FillChar(subject, 72, 0);
FillChar(date, 20, 0);
times := 0;
orig_node := this_node;
cost := 0;
orig_net := this_net;
prev_msg := $00;
attr_low := low;
attr_high := $01;
next_msg := $00;
{$V-}
caps_to_mixed(from_name);
Move(from_name[1], msg_from, Length(from_name));
caps_to_mixed(to_name) {$V+} ;
Move(to_name[1], msg_to, Length(to_name));
Move(subj[1], subject, Length(subj));
Move(DateStr[1], date, Length(DateStr));
end;
if Area = 'NETMAIL' then
begin
FidoArea := fidomail;
msg_hdr.cost := node_hdr.node_cost;
end
else
FidoArea := fidomail+'\'+Area;
SetSect(FidoArea);
Assign(fido_file, msgnum+'.MSG');
{$I-}
Rewrite(fido_file) {$I+} ;
OK := (IoResult = 0);
if OK then
begin
Write(fido_file, msg_hdr);
Close(fido_file);
Assign(fido_message, msgnum+'.TXT');
{$I-}
Rewrite(fido_message) {$I+} ;
OK := (IoResult = 0);
if OK then
begin
{$I-}
ReadLn(mfile, prev_line) {$I+} ;
prev_line := Detab(prev_line, 8);
msg_line := prev_line;
while (not EoF(mfile)) do
begin
ReadLn(mfile, msg_line);
msg_line := Detab(msg_line, 8);
if (Pos(' ', msg_line) = 1) or (msg_line = '') then
prev_line := prev_line+CR+LF
else
prev_line := prev_line+' '+SoftCR;
if prev_line = ' '+SoftCR then
prev_line := CR+LF;
Write(fido_message, prev_line);
prev_line := msg_line;
end;
WriteLn(fido_message, msg_line);
Close(mfile);
if source <> '' then
Erase(mfile);
if created then
begin
SetSect(HomName);
Erase(mfile);
if Pos('.', mname) <> 0 then
Delete(mname, Pos('.', mname), 4);
Assign(mfile, mname+'.BAK');
{$I-}
Reset(mfile); {$I+}
if IoResult = 0 then
begin
Close(mfile);
Erase(mfile);
end;
SetSect(FidoArea)
end;
Close(fido_message);
Assign(msg_file, msgnum+'.MSG');
{$I-}
Reset(msg_file, 1) {$I+} ;
OK := (IoResult = 0);
if OK then
begin
Seek(msg_file, FileSize(msg_file));
Assign(text_file, msgnum+'.TXT');
{$I-}
Reset(text_file, 1) {$I+} ;
OK := (IoResult = 0);
if OK then
begin
remaining := 512;
while remaining = 512 do
begin
BlockRead(text_file, buffer, 512, remaining);
BlockWrite(msg_file, buffer, remaining);
end;
if Area[1] = '-' then
begin
EchoMsgEntr := 2;
if ExistFile('ORIGIN') then
begin
Assign(orig_file, 'ORIGIN');
Reset(orig_file);
ReadLn(orig_file, sect_orig);
sect_orig := ' * Origin: '+sect_orig+
' ('+my_zone+':'+my_net+'/'+my_node+')'
+CR+LF;
Close(orig_file);
end
else
sect_orig := orig_line;
msg_footer := tear_line+sect_orig+
seenby_line;
for i := 1 to Length(msg_footer) do
buffer[i] := Ord(msg_footer[i]);
BlockWrite(msg_file, buffer,
Length(msg_footer));
end
else
NetMsgEntr := 1;
for i := 1 to 5 do
buffer[i] := 0;
BlockWrite(msg_file, buffer, 5);
Close(msg_file);
Close(text_file);
Erase(text_file);
if (Area[1] <> '-') and (node_hdr.node_cost > 0) then
Write(Com, 'This message will cost ',
node_hdr.node_cost, ' cents. ');
if (area[1] <> '-') and (node_hdr.node_cost > 0) and
(not ask('Do you want to send it', 'Y')) then
begin
Erase(msg_file);
WriteLn(Com);
WriteLn(Com, 'Message not saved.');
end
else
begin
if area[1] <> '-' then
user_rec.acct_bal := user_rec.acct_bal-node_hdr.node_cost;
WriteLn(Com);
WriteLn(Com, 'Message built.');
end;
end
else
WriteLn(Com,
'Message not filed due to I/O problems.');
end;
end;
end;
SetSect(HomName);
end;
end;
end;
end; {Name<>' '}
end;
end.
